home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / graphics.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  16KB  |  438 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; CLX drawing requests
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(
  24.       draw-point
  25.       draw-points
  26.       draw-line
  27.       draw-lines
  28.       draw-segments
  29.       draw-rectangle
  30.       draw-rectangles
  31.       draw-arc
  32.       draw-arcs
  33.       put-raw-image
  34.       get-raw-image))
  35.  
  36. (defvar *inhibit-appending* nil)
  37.  
  38. (defun draw-point (drawable gcontext x y)
  39.   ;; Should be clever about appending to existing buffered protocol request.
  40.   (declare (type drawable drawable)
  41.        (type gcontext gcontext)
  42.        (type int16 x y))
  43.   (let ((display (drawable-display drawable)))
  44.     (with-display (display)
  45.       (force-gcontext-changes gcontext)
  46.       (writing-buffer-send (display)
  47.     (let* ((last-request-byte (display-last-request display))
  48.            (current-boffset buffer-boffset))
  49.       ;; To append or not append, that is the question
  50.       (if (and (not *inhibit-appending*)
  51.            last-request-byte
  52.            ;; Same request?
  53.            (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
  54.            (progn ;; Set buffer pointers to last request
  55.              (set-buffer-offset last-request-byte)
  56.              ;; same drawable and gcontext?
  57.              (or (compare-request (4)
  58.                (data 0)
  59.                (drawable drawable)
  60.                (gcontext gcontext))
  61.              (progn ;; If failed, reset buffer pointers
  62.                (set-buffer-offset current-boffset)
  63.                nil))))
  64.           ;; Append request
  65.           (progn
  66.         ;; Set new request length        
  67.         (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
  68.                            -2)))
  69.         (set-buffer-offset current-boffset :sizes 16)
  70.         (put-items (0)            ; Insert new point
  71.           (int16 x y))
  72.         (setf (display-boffset display) (index+ buffer-boffset 4)))
  73.         ;; New Request
  74.         (progn
  75.           (put-items (4)
  76.         (code *x-polypoint*)
  77.         (data 0) ;; Relative-p false
  78.         (length 4)
  79.         (drawable drawable)
  80.         (gcontext gcontext)
  81.         (int16 x y))
  82.           (incf (buffer-request-number display))
  83.           (setf (buffer-last-request display) buffer-boffset)
  84.           (setf (display-boffset display) (index+ buffer-boffset 16)))))))
  85.     (display-invoke-after-function display)))
  86.  
  87.  
  88. (defun draw-points (drawable gcontext points &optional relative-p)
  89.   (declare (type drawable drawable)
  90.        (type gcontext gcontext)
  91.        (type sequence points)        ;(repeat-seq (integer x) (integer y))
  92.        (type boolean relative-p))
  93.   (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
  94.     ((data boolean) relative-p)
  95.     (drawable drawable)
  96.     (gcontext gcontext)
  97.     ((sequence :format int16) points)))
  98.  
  99. (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
  100.   ;; Should be clever about appending to existing buffered protocol request.
  101.   (declare (type drawable drawable)
  102.        (type gcontext gcontext)
  103.        (type int16 x1 y1 x2 y2)
  104.        (type boolean relative-p))
  105.   (let ((display (drawable-display drawable)))
  106.     (when relative-p
  107.       (incf x2 x1)
  108.       (incf y2 y1))
  109.     (with-display (display)
  110.       (force-gcontext-changes gcontext)
  111.       (writing-buffer-send (display)
  112.     (let* ((last-request-byte (display-last-request display))
  113.            (current-boffset buffer-boffset))
  114.       ;; To append or not append, that is the question
  115.       (if (and (not *inhibit-appending*)
  116.            last-request-byte
  117.            ;; Same request?
  118.            (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
  119.            (progn ;; Set buffer pointers to last request
  120.              (set-buffer-offset last-request-byte :sizes (16 32))
  121.              ;; same drawable and gcontext?
  122.              (or (compare-request (4)
  123.                (drawable drawable)
  124.                (gcontext gcontext))
  125.              (progn ;; If failed, reset buffer pointers
  126.                (set-buffer-offset current-boffset :sizes (16 32))
  127.                nil))))
  128.           ;; Append request
  129.           (progn
  130.         ;; Set new request length
  131.         (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
  132.                            -2)))
  133.         (set-buffer-offset current-boffset :sizes 16)
  134.         (put-items (0)            ; Insert new point
  135.           (int16 x1 y1 x2 y2))
  136.         (setf (display-boffset display) (index+ buffer-boffset 8)))
  137.         ;; New Request
  138.         (progn
  139.           (put-items (4)
  140.         (code *x-polysegment*)
  141.         (length 5)
  142.         (drawable drawable)
  143.         (gcontext gcontext)
  144.         (int16 x1 y1 x2 y2))
  145.           (incf (buffer-request-number display))
  146.           (setf (buffer-last-request display) buffer-boffset)
  147.           (setf (display-boffset display) (index+ buffer-boffset 20)))))))
  148.     (display-invoke-after-function display)))
  149.  
  150. (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
  151.   (declare (type drawable drawable)
  152.        (type gcontext gcontext)
  153.        (type sequence points) ;(repeat-seq (integer x) (integer y))
  154.        (type boolean relative-p fill-p)
  155.        (type (member :complex :non-convex :convex) shape))
  156.   (if fill-p
  157.       (fill-polygon drawable gcontext points relative-p shape)
  158.     (with-buffer-request ((drawable-display drawable)  *x-polyline* :gc-force gcontext)
  159.       ((data boolean) relative-p)
  160.       (drawable drawable)
  161.       (gcontext gcontext)
  162.       ((sequence :format int16) points))))
  163.  
  164. ;; Internal function called from DRAW-LINES
  165. (defun fill-polygon (drawable gcontext points relative-p shape)
  166.   ;; This is clever about appending to previous requests.  Should it be?
  167.   (declare (type drawable drawable)
  168.        (type gcontext gcontext)
  169.        (type sequence points)        ;(repeat-seq (integer x) (integer y))
  170.        (type boolean relative-p)
  171.        (type (member :complex :non-convex :convex) shape))
  172.   (with-buffer-request ((drawable-display drawable)  *x-fillpoly* :gc-force gcontext)
  173.     (drawable drawable)
  174.     (gcontext gcontext)
  175.     ((member8 :complex :non-convex :convex) shape)
  176.     (boolean relative-p)
  177.     ((sequence :format int16) points)))
  178.  
  179. (defun draw-segments (drawable gcontext segments)
  180.   (declare (type drawable drawable)
  181.        (type gcontext gcontext)
  182.        ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
  183.        (type sequence segments)) 
  184.   (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
  185.     (drawable drawable)
  186.     (gcontext gcontext)
  187.     ((sequence :format int16) segments)))
  188.  
  189. (defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
  190.   ;; Should be clever about appending to existing buffered protocol request.
  191.   (declare (type drawable drawable)
  192.        (type gcontext gcontext)
  193.        (type int16 x y)
  194.        (type card16 width height)
  195.        (type boolean fill-p))
  196.   (let ((display (drawable-display drawable))
  197.     (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
  198.     (with-display (display)
  199.       (force-gcontext-changes gcontext)
  200.       (writing-buffer-send (display)
  201.     (let* ((last-request-byte (display-last-request display))
  202.            (current-boffset buffer-boffset))
  203.       ;; To append or not append, that is the question
  204.       (if (and (not *inhibit-appending*)
  205.            last-request-byte
  206.            ;; Same request?
  207.            (= (aref-card8 buffer-bbuf last-request-byte) request)
  208.            (progn ;; Set buffer pointers to last request
  209.              (set-buffer-offset last-request-byte)
  210.              ;; same drawable and gcontext?
  211.              (or (compare-request (4)
  212.                (drawable drawable)
  213.                (gcontext gcontext))
  214.              (progn ;; If failed, reset buffer pointers
  215.                (set-buffer-offset current-boffset)
  216.                nil))))
  217.           ;; Append request
  218.           (progn
  219.         ;; Set new request length
  220.         (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
  221.                            -2)))
  222.         (set-buffer-offset current-boffset :sizes 16)
  223.         (put-items (0)            ; Insert new point
  224.           (int16 x y)
  225.           (card16 width height))
  226.         (setf (display-boffset display) (index+ buffer-boffset 8)))
  227.         ;; New Request
  228.         (progn
  229.           (put-items (4)
  230.         (code request)
  231.         (length 5)
  232.         (drawable drawable)
  233.         (gcontext gcontext)
  234.         (int16 x y)
  235.         (card16 width height))
  236.           (incf (buffer-request-number display))
  237.           (setf (buffer-last-request display) buffer-boffset)
  238.           (setf (display-boffset display) (index+ buffer-boffset 20)))))))
  239.     (display-invoke-after-function display)))
  240.  
  241. (defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
  242.   (declare (type drawable drawable)
  243.        (type gcontext gcontext)
  244.        ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
  245.        (type sequence rectangles)
  246.        (type boolean fill-p))
  247.   (with-buffer-request ((drawable-display drawable)
  248.             (if fill-p *x-polyfillrectangle* *x-polyrectangle*)
  249.             :gc-force gcontext)
  250.     (drawable drawable)
  251.     (gcontext gcontext)
  252.     ((sequence :format int16) rectangles)))
  253.  
  254. (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
  255.   ;; Should be clever about appending to existing buffered protocol request.
  256.   (declare (type drawable drawable)
  257.        (type gcontext gcontext)
  258.        (type int16 x y)
  259.        (type card16 width height)
  260.        (type angle angle1 angle2)
  261.        (type boolean fill-p))
  262.   (let ((display (drawable-display drawable))
  263.     (request (if fill-p *x-polyfillarc* *x-polyarc*)))
  264.     (with-display (display)
  265.       (force-gcontext-changes gcontext)
  266.       (writing-buffer-send (display)
  267.     (let* ((last-request-byte (display-last-request display))
  268.            (current-boffset buffer-boffset))
  269.       ;; To append or not append, that is the question
  270.       (if (and (not *inhibit-appending*)
  271.            last-request-byte
  272.            ;; Same request?
  273.            (= (aref-card8 buffer-bbuf last-request-byte) request)
  274.            (progn ;; Set buffer pointers to last request
  275.              (set-buffer-offset last-request-byte)
  276.              ;; same drawable and gcontext?
  277.              (or (compare-request (4)
  278.                (drawable drawable)
  279.                (gcontext gcontext))
  280.              (progn ;; If failed, reset buffer pointers
  281.                (set-buffer-offset current-boffset)
  282.                nil))))
  283.           ;; Append request
  284.           (progn
  285.         ;; Set new request length        
  286.         (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
  287.                            -2)))
  288.         (set-buffer-offset current-boffset :sizes 16)
  289.         (put-items (0)            ; Insert new point
  290.           (int16 x y)
  291.           (card16 width height)
  292.           (angle angle1 angle2))
  293.         (setf (display-boffset display) (index+ buffer-boffset 12)))
  294.         ;; New Request
  295.         (progn
  296.           (put-items (4)
  297.         (code request)
  298.         (length 6)
  299.         (drawable drawable)
  300.         (gcontext gcontext)
  301.         (int16 x y)
  302.         (card16 width height)
  303.         (angle angle1 angle2))
  304.           (incf (buffer-request-number display))
  305.           (setf (buffer-last-request display) buffer-boffset)
  306.           (setf (display-boffset display) (index+ buffer-boffset 24)))))))
  307.     (display-invoke-after-function display)))
  308.  
  309. (defun draw-arcs (drawable gcontext arcs &optional fill-p)
  310.   (declare (type drawable drawable)
  311.        (type gcontext gcontext)
  312.        ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)
  313.        (type sequence arcs) 
  314.        ;; (angle angle1) (angle angle2))
  315.        (type boolean fill-p))
  316.   (let* ((display (drawable-display drawable))
  317.      (size (display-size display))
  318.      (length (length arcs))
  319.      (request (if fill-p *x-polyfillarc* *x-polyarc*)))
  320.     (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
  321.       (drawable drawable)
  322.       (gcontext gcontext)
  323.       (progn
  324.     (card16-put 2 (+ (ash length -1) 3))    ; Set request length (in words)
  325.     (incf buffer-boffset 12)        ; Position to start of data
  326.     (etypecase arcs
  327.       (list  ;; Fast loop so ELT doesn't have to cdr down the list each time
  328.        (do ((arc arcs))
  329.            ((endp arc)
  330.         (setf (buffer-boffset display) buffer-boffset))
  331.          (set-buffer-offset buffer-boffset :sizes (16))
  332.          (int16-put 0 (pop arc))
  333.          (int16-put 2 (pop arc))
  334.          (card16-put 4 (pop arc))
  335.          (card16-put 6 (pop arc))
  336.          (angle-put 8 (pop arc))
  337.          (angle-put 10 (pop arc))
  338.          (incf buffer-boffset 12)
  339.          (when (>= buffer-boffset size)
  340.            (setf (buffer-boffset display) buffer-boffset)
  341.            (buffer-flush display)
  342.            (setq buffer-boffset (display-boffset display)))))
  343.  
  344.       (vector  ;; Fast loop uses AREF instead of ELT
  345.        (do ((n 0 (+ n 6))
  346.         (length (length arcs)))
  347.            ((> n length)
  348.         (setf (buffer-boffset display) buffer-boffset))
  349.          (set-buffer-offset buffer-boffset :sizes (16))
  350.          (int16-put 0 (aref arcs (+ n 0)))
  351.          (int16-put 2 (aref arcs (+ n 1)))
  352.          (card16-put 4 (aref arcs (+ n 2)))
  353.          (card16-put 6 (aref arcs (+ n 3)))
  354.          (angle-put 8 (aref arcs (+ n 4)))
  355.          (angle-put 10 (aref arcs (+ n 5)))
  356.          (incf buffer-boffset 12)
  357.          (when (>= buffer-boffset size)
  358.            (setf (buffer-boffset display) buffer-boffset)
  359.            (buffer-flush display)
  360.            (setq buffer-boffset (display-boffset display))))))))))
  361.  
  362. ;; The following image routines are bare minimum.  It may be useful to define
  363. ;; some form of "image" object to hide representation details and format
  364. ;; conversions.  It also may be useful to provide stream-oriented interfaces
  365. ;; for reading and writing the data.
  366.  
  367. (defun put-raw-image (drawable gcontext data &key
  368.               (start 0)
  369.               (depth (required-arg depth))
  370.               (x (required-arg x))
  371.               (y (required-arg y))
  372.               (width (required-arg width))
  373.               (height (required-arg height))
  374.               (left-pad 0)
  375.               (format (required-arg format)))
  376.   ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
  377.   ;; for transmission; the caller is responsible for all byte and bit swapping and
  378.   ;; compaction.  Start is the starting index in data; the end is computed from the
  379.   ;; other arguments.
  380.   (declare (type drawable drawable)
  381.        (type gcontext gcontext)
  382.        (type sequence data) ; Sequence of integers
  383.        (type array-index start)
  384.        (type card8 depth left-pad) ;; required
  385.        (type int16 x y) ;; required
  386.        (type card16 width height) ;; required
  387.        (type (member :bitmap :xy-pixmap :z-pixmap) format))
  388.   (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
  389.     ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
  390.     (drawable drawable)
  391.     (gcontext gcontext)
  392.     (card16 width height)
  393.     (int16 x y)
  394.     (card8 left-pad depth)
  395.     (pad16 nil)
  396.     ((sequence :format card8 :start start) data)))
  397.  
  398. (defun get-raw-image (drawable &key
  399.               data
  400.               (start 0)
  401.               (x (required-arg x))
  402.               (y (required-arg y))
  403.               (width (required-arg width))
  404.               (height (required-arg height))
  405.               (plane-mask #xffffffff)
  406.               (format (required-arg format))
  407.               (result-type '(vector card8)))
  408.   ;; If data is given, it is modified in place (and returned), otherwise a new sequence
  409.   ;; is created and returned, with a size computed from the other arguments and the
  410.   ;; returned depth.  The sequence is filled with 8-bit quantities, in transmission
  411.   ;; format; the caller is responsible for any byte and bit swapping and compaction
  412.   ;; required for further local use.
  413.   (declare (type drawable drawable)
  414.        (type (or null sequence) data) ;; sequence of integers
  415.        (type int16 x y) ;; required
  416.        (type card16 width height) ;; required
  417.        (type array-index start)
  418.        (type pixel plane-mask)
  419.        (type (member :xy-pixmap :z-pixmap) format))
  420.   (declare-values (sequence integer) depth visual)
  421.   (let ((display (drawable-display drawable))
  422.     seq depth visual)
  423.     (with-display (display)
  424.       (with-buffer-request (display *x-getimage* :no-after)
  425.     ((data (member error :xy-pixmap :z-pixmap)) format)
  426.     (drawable drawable)
  427.     (int16 x y)
  428.     (card16 width height)
  429.     (card32 plane-mask))
  430.       (with-buffer-reply (display nil :sizes (8 32))
  431.     (setq depth (card8-get 1)
  432.           visual (resource-id-get 8))
  433.     (let ((length (* 4 (card32-get 4))))
  434.       (setq seq (sequence-get :result-type result-type :format card8
  435.                   :length length :start start :data data)))))
  436.     (display-invoke-after-function display)
  437.     (values seq depth visual)))
  438.